(load-relative "loadtest.rktl")

(Section 'gambit-numeric)

;; tests adapted from Gambit numeric unit tests, see gambit/unit-tests/03-number

(require racket/flonum
         racket/fixnum
         racket/function
         racket/list
         racket/symbol
         racket/keyword
         (prefix-in k: '#%kernel))

(define =~ (lambda (a b)
             (or (eqv? a b)
                 (and (< (abs (- (real-part a) (real-part b))) epsilon)
                      (< (abs (- (imag-part a) (imag-part b))) epsilon)))))
(define epsilon 1e-12)
(define (macro-cpxnum-+1/2+sqrt3/2i)
  (make-rectangular 1/2 (/ (sqrt 3) 2)))

(define (macro-cpxnum-+1/2-sqrt3/2i)
  (make-rectangular 1/2 (- (/ (sqrt 3) 2))))

(define (macro-cpxnum--1/2+sqrt3/2i)
  (make-rectangular -1/2 (/ (sqrt 3) 2)))

(define (macro-cpxnum--1/2-sqrt3/2i)
  (make-rectangular -1/2 (- (/ (sqrt 3) 2))))

(define (macro-cpxnum-+sqrt3/2+1/2i)
  (make-rectangular (/ (sqrt 3) 2) 1/2))

(define (macro-cpxnum-+sqrt3/2-1/2i)
  (make-rectangular (/ (sqrt 3) 2) -1/2))

(define (macro-cpxnum--sqrt3/2+1/2i)
  (make-rectangular (- (/ (sqrt 3) 2)) 1/2))

(define (macro-cpxnum--sqrt3/2-1/2i)
  (make-rectangular (- (/ (sqrt 3) 2)) -1/2))

(define (test-atanh z)
  (* 1/2 (- (log (+ 1 z)) (log (- 1 z)))))

(define (test-atan z)
  (/ (test-atanh (* +i z)) +i))

(define (test-asinh z)
  (log (+ z (sqrt (+ (* z z) 1)))))

(define (test-asin z)
  (/ (test-asinh (* +i z)) +i))

(define (test-acos z)
  (- (macro-inexact-+pi/2) (test-asin z)))

(define (test-acosh z)
  (* 2 (log (+ (sqrt (/ (+ z 1) 2)) (sqrt (/ (- z 1) 2))))))

(define (test-complex-+ x y)
  (let ((a (real-part x)) (b (imag-part x))
	(c (real-part y)) (d (imag-part y)))
    (make-rectangular (+ a c)
		      (+ b d))))

(define (test-complex-- x y)
  (let ((a (real-part x)) (b (imag-part x))
	(c (real-part y)) (d (imag-part y)))
    (make-rectangular (- a c)
		      (- b d))))

(define (test-complex-* x y)
  (let ((a (real-part x)) (b (imag-part x))
	(c (real-part y)) (d (imag-part y)))
    (make-rectangular (- (* a c) (* b d))
		      (+ (* a d) (* b c)))))


(set! epsilon 1e-12)

(define (test-bitwise-ior x y)
  (cond ((or (= x -1)
	     (= y -1))
	 -1)
	((and (= x 0)
	      (= y 0))
	 0)
	(else (+ (* 2 (test-bitwise-ior (arithmetic-shift x -1)
					(arithmetic-shift y -1)))
		 (if (or (odd? x) (odd? y))
		     1
		     0)))))

(define (test-bitwise-and x y)
  (cond ((or (= x 0)
	     (= y 0))
	 0)
	((and (= x -1)
	      (= y -1))
	 -1)
	(else (+ (* 2 (test-bitwise-and (arithmetic-shift x -1)
					(arithmetic-shift y -1)))
		 (if (and (odd? x) (odd? y))
		     1
		     0)))))

(define (test-bitwise-xor x y)
  (cond ((= x y)
	 0)
	((or (and (= x -1)
		  (= y 0))
	     (and (= x 0)
		  (= y -1)))
	 -1)
	(else
	 (+ (* 2 (test-bitwise-xor (arithmetic-shift x -1)
				   (arithmetic-shift y -1)))
	    (if (eq? (odd? x) (odd? y))
		0
		1)))))

(define (test-bitwise-not x)
  (- -1 x))

(define (test-bitwise-andc1 x y)
  (test-bitwise-and (test-bitwise-not x) y))

(define (test-bitwise-andc2 x y)
  (test-bitwise-and x (test-bitwise-not y)))

(define (test-bitwise-eqv x y)
  (test-bitwise-not (test-bitwise-xor x y)))

(define (test-bitwise-nand x y)
  (test-bitwise-not (test-bitwise-and x y)))

(define (test-bitwise-nor x y)
  (test-bitwise-not (test-bitwise-ior x y)))

(define (test-bitwise-orc1 x y)
  (test-bitwise-ior (test-bitwise-not x) y))

(define (test-bitwise-orc2 x y)
  (test-bitwise-ior x (test-bitwise-not y)))

(define (test-arithmetic-shift x n)
  (if (negative? n)
      (let* ((q (expt 2 (- n)))
	     (bits (modulo x q)))
	(quotient (- x bits) q))
      (* x (expt 2 n))))

(define (test-extract-bit-field size position n)
  (bitwise-and (arithmetic-shift n (- position))
	       (bitwise-not (arithmetic-shift -1 size))))

(define (test-test-bit-field? size position n)
  (not (eqv? (test-extract-bit-field size position n)
	     0)))

(define (test-clear-bit-field size position n)
  (bitwise-ior (arithmetic-shift (arithmetic-shift n (- (+ size position))) (+ size position))
	       (test-extract-bit-field position 0 n)))

(define (macro-inexact-+pi)     3.141592653589793)
(define (macro-inexact--pi)    -3.141592653589793)
(define (macro-inexact-+pi/2)   1.5707963267948966)
(define (macro-inexact--pi/2)  -1.5707963267948966)
(define (macro-inexact-+pi/4)    .7853981633974483)
(define (macro-inexact--pi/4)   -.7853981633974483)
(define (macro-inexact-+3pi/4)  2.356194490192345)
(define (macro-inexact--3pi/4) -2.356194490192345)

(define (exact v) (if (exact? v) v (inexact->exact v)))
(define (inexact v) (if (inexact? v) v (exact->inexact v)))

(define (isnan? x) (not (= x x)))

(err/rt-test (abs #\c))
(err/rt-test (abs 0+1i))
(test 0 acos 1)
(test/compare =~ (test-acos 2) acos 2)
(test/compare =~ (test-acos 2.0+0.0i) acos 2.0+0.0i)
(test/compare =~ (test-acos 2.0-0.0i) acos 2.0-0.0i)
(test/compare =~ (test-acos -2) acos -2)
(test/compare =~ (test-acos -2.0+0.0i) acos -2.0+0.0i)
(test/compare =~ (test-acos -2.0-0.0i) acos -2.0-0.0i)
(test/compare =~ (test-acos -1234000000.0-0.0i) acos -1234000000.0-0.0i)
(err/rt-test (acos 'a))
(err/rt-test (angle 'a))
(test 0 asin 0)
(test/compare =~ (test-asin 2) asin 2)
(test/compare =~ (test-asin 2.0+0.0i) asin 2.0+0.0i)
(test/compare =~ (test-asin 2.0-0.0i) asin 2.0-0.0i)
(test/compare =~ (test-asin -2) asin -2)
(test/compare =~ (test-asin -2.0+0.0i) asin -2.0+0.0i)
(test/compare =~ (test-asin -2.0-0.0i) asin -2.0-0.0i)
(test 1e-30+1e-40i asin 1e-30+1e-40i)
(test/compare =~ (test-asin -1234000000.0-0.0i) asin -1234000000.0-0.0i)
(err/rt-test (asin 'a))
(test (test-complex-+ 1.0+2.0i 6.4+8.2i) + 1.0+2.0i 6.4+8.2i)
(test (test-complex-- 1.0+2.0i 6.4+8.2i) - 1.0+2.0i 6.4+8.2i)
(test (test-complex-* 1.0+2.0i 64.0+82.0i) * 1.0+2.0i 64.0+82.0i)
(test (test-complex-+ 1+2i 64+82i) + 1+2i 64+82i)
(test (test-complex-- 1+2i 64+82i) - 1+2i 64+82i)
(test (test-complex-* 1+2i 64+82i) * 1+2i 64+82i)
(err/rt-test (conjugate 'a))
(test 1 cos 0)
(err/rt-test (cos 'a))
(test 5 denominator (/ -12 -10))
(test 123.0 exact->inexact 123.0)
(test 0.5 exact->inexact 0.5)
(test 123.0 exact->inexact 123)
(test 0.5 exact->inexact 1/2)
(test 0.5+0.75i exact->inexact 1/2+3/4i)
(err/rt-test (exact->inexact 'a))
(test #f exact-integer? 123.0)
(test #f exact-integer? 0.5)
(test #t exact-integer? 123)
(test #t exact-integer? 100000000000000000000)
(test #f exact-integer? 1/2)
(test #f exact-integer? 1/2+3/4i)
(test #f exact-integer? 123.0+0.0i)
(err/rt-test (exact-integer?))
(err/rt-test (exact-integer? 0 0))
(test 123 exact 123)
(test 1/2 exact 1/2)
(test 123 exact 123.0)
(test 1/2 exact 0.5)
(test 1/2+3/4i exact 0.5+0.75i)
(err/rt-test (exact 'a))
(err/rt-test (exp #\c))
(err/rt-test (imag-part 'a))
(test 123 inexact->exact 123)
(test 1/2 inexact->exact 1/2)
(test 123 inexact->exact 123.0)
(test 1/2 inexact->exact 0.5)
(test 1/2+3/4i inexact->exact 0.5+0.75i)
(err/rt-test (inexact->exact 'a))
(test 123.0 inexact 123.0)
(test 0.5 inexact 0.5)
(test 123.0 inexact 123)
(test 0.5 inexact 1/2)
(test 0.5+0.75i inexact 1/2+3/4i)
(err/rt-test (inexact 'a))
(test 0 integer-sqrt 0)
(test 31 integer-sqrt 1000)
(test 31622776601 integer-sqrt 1000000000000000000000)
(err/rt-test (integer-sqrt #f))
(err/rt-test (integer-sqrt))
(err/rt-test (integer-sqrt 0 0))
(test/compare =~ +inf.0 magnitude (make-rectangular +nan.0 +inf.0))
(test/compare =~ +inf.0 magnitude (make-rectangular +inf.0 +nan.0))
(err/rt-test (magnitude 'a))
(err/rt-test (make-polar 'a 2))
(err/rt-test (make-polar 2 'a))
(err/rt-test (make-polar 2 0+1i))
(err/rt-test (make-polar 0+1i 2))
(err/rt-test (make-rectangular 'a 2))
(err/rt-test (make-rectangular 2 'a))
(err/rt-test (make-rectangular 2 0+1i))
(err/rt-test (make-rectangular 0+1i 2))
(test "0" number->string 0)
(test "123" number->string 123)
(test "-123" number->string -123)
(test "1111011" number->string 123 2)
(test "-1111011" number->string -123 2)
(test "7b" number->string 123 16)
(test "-7b" number->string -123 16)
(test "123456789012345678901234567890" number->string 123456789012345678901234567890)
(test "2/7" number->string 2/7)
(test "-inf.0" number->string -inf.0)
(err/rt-test (number->string 'a))
(err/rt-test (number->string 1 'a))
(err/rt-test (number->string 1 30))
(err/rt-test (real-part 'a))
(test 0 sinh 0)
(test (imag-part (sin 0+1i)) sinh 1)
(test 1e-30+1e-40i sinh 1e-30+1e-40i)
(err/rt-test (asinh 'a))
(test 0 sin 0)
(test 1e-30+1e-40i sin 1e-30+1e-40i)
(err/rt-test (sin 'a))
(test 0+1i sqrt -1)
(test/compare =~ 0+1i sqrt -1.0+0.0i)
(test/compare =~ 0-1i sqrt -1.0-0.0i)
(test 0+1i sqrt -1)
(test 1+1i sqrt 0+2i)
(test 1-1i sqrt 0-2i)
(err/rt-test (sqrt #\c))
(test 0 string->number "0")
(test 123 string->number "123")
(test -123 string->number "-123")
(test 123 string->number "1111011" 2)
(test -123 string->number "-1111011" 2)
(test 123 string->number "7b" 16)
(test -123 string->number "-7b" 16)
(test 123456789012345678901234567890 string->number "123456789012345678901234567890")
(test 2/7 string->number "2/7")
(test -0.0 string->number "-0.")
(test -inf.0 string->number "-inf.0")
(test 0.001953125 string->number ".001953125")
(test 0.0009765625 string->number "9.765625e-4")
(test -1.5+0.6666666666666666i string->number "-1.5+2/3i")
(err/rt-test (string->number 1))
(err/rt-test (string->number "" 'a))
(err/rt-test (string->number "" 30))
(test 0 tanh 0)
(test (imag-part (tan 0+1i)) tanh 1)
(test 1e-30+1e-40i tanh 1e-30+1e-40i)
(err/rt-test (tanh 'a))
(test 0 tan 0)
(test 1e-30+1e-40i tan 1e-30+1e-40i)
(err/rt-test (tan 'a))

;; these tests differ from the gambit behavior
(test 0+1i integer-sqrt -1)
(test +inf.0 magnitude (make-rectangular +nan.0 (expt 2 5000)))
(test +inf.0 magnitude (make-rectangular (expt 2 5000) +nan.0))
(test "-0.0" number->string -0.0)
(test "0.001953125" number->string 0.001953125)
(test "0.0009765625" number->string 0.0009765625)
(test "-1.5+0.6666666666666666i" number->string -1.5+0.6666666666666666i)
